home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / examples.zoo / closette / newcl.lsp < prev   
Lisp/Scheme  |  1991-10-22  |  5KB  |  131 lines
  1. ;;;-*-Mode:LISP; Package:NEWCL; Base:10; Syntax:Common-lisp -*-
  2.  
  3. ;;; This is the file newcl.lisp
  4.  
  5. (in-package 'newcl :use '(lisp))
  6. (shadow '(defun fmakunbound fboundp))
  7. (export '(fdefinition defun fmakunbound fboundp print-unreadable-object))
  8.  
  9. ;;; New macros to support function names like (setf foo).
  10.  
  11. (lisp:defun setf-function-symbol (function-specifier)
  12.   (if (consp function-specifier)
  13.     ; make a unique symbol from the function-specifier
  14.     (let ((sym1 (first function-specifier))
  15.           (sym2 (second function-specifier)))
  16.       (intern (concatenate 'string "(" (symbol-name sym1) " " (symbol-name sym2) ")")
  17.               (symbol-package sym2)
  18.     ) )
  19.     function-specifier
  20. ) )
  21.  
  22. (lisp:defun fboundp (function-specifier)
  23.   (if (consp function-specifier)
  24.     (lisp:fboundp (setf-function-symbol function-specifier))
  25.     (lisp:fboundp function-specifier)
  26. ) )
  27.  
  28. (lisp:defun fdefinition (function-specifier)
  29.   (if (consp function-specifier)
  30.     (lisp:symbol-function (setf-function-symbol function-specifier))
  31.     (lisp:symbol-function function-specifier)
  32. ) )
  33.  
  34. (lisp:defun fmakunbound (function-specifier)
  35.   (if (consp function-specifier)
  36.     (lisp:fmakunbound (setf-function-symbol function-specifier))
  37.     (lisp:fmakunbound function-specifier)
  38. ) )
  39.  
  40. (defsetf fdefinition (function-specifier) (new-value)
  41.   `(set-fdefinition ,function-specifier ,new-value)
  42. )
  43.  
  44. (lisp:defun set-fdefinition (function-specifier new-value)
  45.   (if (consp function-specifier)
  46.     (let ((setf-symbol (setf-function-symbol function-specifier)))
  47.       (setf (symbol-function setf-symbol) new-value)
  48.       (eval
  49.         `(defsetf ,(second function-specifier) (&rest all-args) (new-value)
  50.            (list* ',setf-symbol new-value all-args)
  51.          )
  52.       )
  53.       new-value
  54.     )
  55.     (setf (symbol-function function-specifier) new-value)
  56. ) )
  57.  
  58. (defmacro defun (name formals &body body)
  59.   (cond ((symbolp name) `(lisp:defun ,name ,formals ,@body))
  60.         ((and (consp name) (eq (first name) 'setf))
  61.          (let ((setf-symbol (setf-function-symbol name)))
  62.            `(progn
  63.               (lisp:defun ,setf-symbol ,formals ,@body)
  64.               (defsetf ,(second name) ,(cdr formals) (,(car formals))
  65.                 (list ',setf-symbol ,@formals)
  66.             ) )
  67.         ))
  68.         (t (error "Kein Funktionsname: ~S" name))
  69. ) )
  70.  
  71. #| Minimal tests:
  72. (macroexpand '(defun (setf foo) (nv x y) (+ x y)))
  73. (defun (setf baz) (new-value arg)
  74.   (format t "setting value of ~A to ~A" arg new-value))
  75. (macroexpand '(setf (baz (+ 2 2)) (* 3 3)))
  76. |#
  77.  
  78. ;;;
  79. ;;; print-unreadable-object
  80. ;;;
  81.  
  82. ;;; print-unreadable-object is the standard way in the new Common Lisp
  83. ;;; to generate #< > around objects that can't be read back in.  The option
  84. ;;; (:identity t) causes the inclusion of a representation of the object's
  85. ;;;  identity, typically some sort of machine-dependent storage address.
  86.  
  87. #+CLISP
  88. (let* ((poke-array-2 (make-array 10))
  89.        (poke-array-1 (make-array 10 :displaced-to poke-array-2 :adjustable t))
  90.        (poke-array (make-array 10 :displaced-to poke-array-1))
  91.        (poke-bignum #x400000000000)) ; Bignum, das 6 Bytes Daten braucht
  92.   (progn
  93.     (when (< (nth-value 1 (room)) 100) (gc))
  94.     (adjust-array poke-array-1 1 :displaced-to (make-array 1))
  95.     (setq poke-bignum (+ poke-bignum 1)) ; neues Bignum allozieren
  96.   )
  97.   ; Nun sieht's im Speicher so aus:
  98.   ;     poke-array-1       poke-bignum
  99.   ; |Self|Länge|1 Elt.| |Self|Länge|Wert|
  100.   ; 0    4     8     12 12   16    18   24
  101.   ; Diese Speicher-Anordnung wird auch von der GC nicht durcheinandergebracht.
  102.   (defun address-of (obj)
  103.     (setf (aref poke-array 3) obj)
  104.     (logand poke-bignum #xFFFFFFFF)
  105.   )
  106. )
  107.  
  108. (defmacro print-unreadable-object ((object stream &key type identity) &body body)
  109.   (let ((stream. (gensym))
  110.         (object. (gensym)))
  111.     `(let ((,stream. ,stream)
  112.            (,object. ,object))
  113.        (write-char #\# ,stream.)
  114.        (write-char #\< ,stream.)
  115.        ,@(when type `((write (type-of ,object.) :stream stream)))
  116.        ,@(when (and type (or body identity)) `((write-char #\Space ,stream.)))
  117.        ,@body
  118.        ,@(when (and identity body) `((write-char #\Space ,stream.)))
  119.        ,@(when identity
  120.            #+Genera `((format ,stream. "~O" (si:%pointer ,object.)))
  121.            #+Lucid  `((format ,stream. "~O" (sys:%pointer ,object.)))
  122.            #+Excl   `((format ,stream. "~O" (excl::pointer-to-fixnum ,object.)))
  123.            #+:coral `((format ,stream. "~O" (ccl::%ptr-to-int ,object.)))
  124.            #+CLISP  `((format ,stream. "#x~6,'0X" (logand (address-of ,object.) #xFFFFFF)))
  125.          )
  126.        (write-char #\> ,stream.)
  127.        nil
  128.      )
  129. ) )
  130.  
  131.